home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Super Shareware Collection
/
Super Shareware Collection.iso
/
info
/
cad08n11.zip
/
DIM3D.LSP
< prev
next >
Wrap
Lisp/Scheme
|
1994-02-01
|
5KB
|
182 lines
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Advanced AutoLISP Concepts
;; Nov 1993 CADENCE W.Kramer
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; DIM_UCS sets up UCS for aligned
;; dimensioning in 3D.
;; Listing 1.
(defun DIM_UCS (EN UCSTYP / EL P1 P2 TMP V)
(cond
((= (type EN) 'ENAME)
(setq EL (entget EN))
(if (= (cdr (assoc 0 EL)) "LINE") ;;line only
(setq P1 (cdr (assoc 10 EL))
P2 (cdr (assoc 11 EL))
)
(prompt "\n(DIM_UCS) entity not a line")
)
)
((and (listp (car EN)) (listp (cadr EN)))
(setq P1 (car EN)
P2 (cadr EN)
)
)
(t
(prompt "\n(DIM_UCS) invalid parameter")
)
)
(if (and P1 P2)
(progn
;; P1 should be min Z
(if (< (caddr P2) (caddr P1))
(setq TMP P1 P1 P2 P2 TMP)
)
;; V is base vector
(setq V (mapcar '- P2 P1))
;; Style selection for UCS
(cond
((or (null UCSTYP)
(= UCSTYP 0)) ;;angle off XY plane
(command
"_UCS"
"_3P"
(trans P1 0 1)
(trans P2 0 1)
(trans
(list
(- (car P1) (cadr V))
(+ (cadr P1) (car V))
(caddr P1)
)
0 1)
);;end COMMAND
);;end case 0
((= UCSTYP 1) ;;perpendicular to XY plane
(setq
DXY
(sqrt
(+
(* (car V) (car V))
(* (cadr V) (cadr V))))
UV
(list
(/ (car V) DXY)
(/ (cadr V) DXY))
)
(command
"_UCS"
"_3P"
(trans P1 0 1)
(trans P2 0 1)
(trans
(list
(+ (car P1)
(* (car UV)
(caddr V)
-1.0))
(+ (cadr P1)
(* (cadr UV)
(caddr V)
-1.0))
(+ (caddr P1)
DXY)
)
0 1)
) ;;end COMMAND
);;end case 1
(t (prompt "\nUCSTYP unknown value!"))
);;end COND
'T
);;end PROGN
);;end IF
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Listing 2
(defun C:DIM3D ()
(initget 0 "0 1")
(setq TMP
(getkword
"\nSelect dimensioning style 0 or 1 <0>: "))
(if (null TMP)
(setq TMP 0)
(setq TMP (atoi TMP))
)
(setq UCSTYP TMP)
;;
(while (setq TMP (dim_getobj))
(dim_ucs TMP UCSTYP) ;;set UCS for dimension object
(command
"_DIM"
"_ALI" ;;aligned dimensions
)
(if (= (type TMP) 'ENAME)
(command ;;if entity, construct pick point
""
(list TMP
(cdr (assoc 10 (entget TMP)))))
(command ;;otherwise, just supply points
(car TMP)
(cadr TMP))
);;end IF
(command PAUSE "");;operator select location
(command "EXIT") ;;terminate DIM command
);;end WHILE
(command "_UCS" "_W") ;;set UCS to world on exit
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Listing 3.
(defun DIM_GETOBJ ( / P1 P2 EN)
(setq P1
(getpoint
"\nFirst point [enter for entity select]: "))
(if (null P1)
(setq EN
(car (entsel "\nSelect LINE entity: ")))
(setq P2
(getpoint P1 " next point: "))
);;end IF
(cond
(EN EN)
((and P1 P2) (list P1 P2))
(t nil)
);;end COND
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Listing 4
(defun C:DIMTEXTFIX ()
(setq EL
(entget
(car
(entsel "\nPick DIMENSION object"))))
(if (and EL
(= (cdr (assoc 0 EL)) "DIMENSION"))
(progn
(setq E2 (tblsearch "BLOCK"
(cdr (assoc 2 EL)))
E1 (cdr (assoc -2 E2))
)
(while E1
(setq E2 (entget E1))
(if (= (cdr (assoc 0 E2)) "TEXT")
(progn
(setq F1 (cdr (assoc 71 E2))
F1 (if (= F1 0) 2 0)
E2 (subst
(cons 71 F1)
(assoc 71 E2)
E2)
)
(entmod E2)
);;end PROGN
);;end IF
(setq E1 (entnext E1))
)
(entupd (cdr (assoc -1 EL)))
);;end PROGN
(prompt "\nDid not pick a DIMENSION object!")
);;end IF
(princ)
)